home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Cream of the Crop 1
/
Cream of the Crop 1.iso
/
PROGRAM
/
TPHERS01.ARJ
/
TPHERSH.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-09-08
|
19KB
|
496 lines
{*****************************************************************************}
{* A unit to manipulate the Hershey glyph (symbol) set. *}
{* *}
{* This code is donated to the Public domain. *}
{* *}
{* Dov Grobgeld *}
{* Department of Chemical Physics *}
{* The Weizmann Institute of Science *}
{* Israel *}
{* Email: dov@menora.weizmann.ac.il *}
{* *}
{* 7/9/1991 *}
{* *}
{* Version 0.1beta *}
{* *}
{* There are only two dependances on BGI in this code, and both have the *}
{* keywords 'BGI dependance' in comments beside them. *}
{*****************************************************************************}
unit TPHersh;
interface
uses graph; { BGI dependance }
{$ifopt n-} type double=real; {$endif} { Use reals if no math coprocessor }
type
HersheyFont = array[#32..#127] of integer;
pHersheyFont = ^HersheyFont;
const
HersheyRomans : HersheyFont = (
699, 714, 717, 733, 719,2271, 734, 731, 721, 722,2219, 725, 711, 724, 710, 720,
700, 701, 702, 703, 704, 705, 706, 707, 708, 709, 712, 713,2241, 726,2242, 715,
2273, 501, 502, 503, 504, 505, 506, 507, 508, 509, 510, 511, 512, 513, 514, 515,
516, 517, 518, 519, 520, 521, 522, 523, 524, 525, 526,2223, 804,2224,2262, 999,
730, 601, 602, 603, 604, 605, 606, 607, 608, 609, 610, 611, 612, 613, 614, 615,
616, 617, 618, 619, 620, 621, 622, 623, 624, 625, 626,2225, 723,2226,2246, 718);
var
HersheyX, HersheyY : integer;
HersheyMaxX, HersheyAspectRatio : double;
procedure HersheySetGlyphsFileName(s : string);
procedure HersheyLoadGlyphs;
procedure HersheyDisplayGlyph(GlyphNum : integer);
procedure HersheyOutTextXY(x,y : integer; s : string);
procedure HersheyOutText(s : string);
procedure HersheySetGlyphSize(xs, ys: double);
procedure HersheyDisposeFont;
procedure HersheySetFont(var pFont);
procedure HersheyMove(x,y : integer);
function HersheyGlyphWidth(GlyphNum : integer) : double;
function HersheyStringWidth(s : string) : double;
procedure HersheySetAngle(theta : double);
procedure HersheySetStringJustify(Horizontal, Vertical : integer);
implementation
const
MaxHersheyChars = 3999;
MaxStrokes = 1000;
type
{*****************************************************************************}
{* The strokes in a character are stored in the file as integers represented *}
{* as characters centered around 'R'. *}
{* *}
{* All characters are drawn around the center of the character. The width *}
{* of the charecter is decided by +-Stroke[0] and the height is determined *}
{* by +-Stroke[1]. *}
{*****************************************************************************}
StrokeVector = array[1..MaxStrokes-1] of char;
pStrokeVector = ^StrokeVector;
HersheyChar = record
numStrokes : byte;
pStroke : pStrokeVector;
end;
HersheyFontType = array[1..MaxHersheyChars] of ^HersheyChar;
const
HersheyGlyphsFileName : string = 'hersh.hfn';
var
HersheyFontArray : ^HersheyFontType;
HersheyCurrentFont : ^HersheyFont;
SinTheta, CosTheta : double; { Rotation of character }
xiScale, nuScale : double;
HStringJust, VStringJust : double;
{*****************************************************************************}
{* Allows the user to chose another font file. *}
{*****************************************************************************}
procedure HersheySetGlyphsFileName(s : string);
begin
HersheyGlyphsFileName:= s;
end;
{*****************************************************************************}
{* FAST block read routines to read the font... *}
{*****************************************************************************}
CONST
BufLen = 8192;
TYPE
RecType = char;
ArrayRecType=Array[1..BufLen] of RecType;
VAR
FontFile : FILE;
InBuf : ^arrayRecType;
InPtr : WORD;
RecRead : WORD;
procedure OpenBlockFiles(p : pointer);
begin
{ Open the font file for unformated input }
Assign(FontFile, HersheyGlyphsFileName); Reset(FontFile, SizeOf(RecType));
RecRead:= 0;
InPtr:= RecRead + 1;
InBuf:= p;
end;
procedure CloseBlockFiles;
begin
close(FontFile);
end;
FUNCTION GetNextRec(VAR _rec; NumRecs : integer): BOOLEAN;
var
rec: ArrayRecType absolute _rec;
RecOfs : integer;
BEGIN
if NumRecs + InPtr <= Recread then begin
move(InBuf^[InPtr], rec[1], NumRecs * sizeof(RecType));
InPtr:= InPtr + NumRecs;
GetNextRec:= TRUE;
end
else begin
if RecRead >= InPtr then begin
move(InBuf^[InPtr], rec[1], (RecRead-InPtr+1) * sizeof(RecType));
RecOfs:= RecRead - InPtr + 1;
end
else RecOfs:= 0;
BlockRead(FontFile, InBuf^, BufLen, RecRead);
IF RecRead = 0 THEN BEGIN
GetNextRec:= FALSE;
Exit;
END;
InPtr:= 1;
move(InBuf^[InPtr], rec[RecOfs+1], (NumRecs - RecOfs) * sizeof(RecType));
InPtr:= InPtr + NumRecs - RecOfs;
end;
END;
{*****************************************************************************}
{* Load the font into memory. *}
{*****************************************************************************}
procedure HersheyLoadGlyphs;
var
numString : string[5];
i : integer;
GlyphNum, numStrokes : integer;
errPos : integer;
Buf : array[1..BufLen] of byte;
crlf : array[1..2] of char;
eofFlag : boolean;
label
exitLoad;
function imin(a,b : integer): integer;
begin
if a<b then imin:= a
else imin:= b;
end;
begin
if HersheyFontArray=nil then begin
new(HersheyFontArray);
{ Zero all characters }
for i:= 1 to MaxHersheyChars do HersheyFontArray^[i]:= nil;
end;
openBlockFiles(@Buf); { Let's use a stack buffer instead of a heap buffer... }
eofFlag:= false;
while not eofFlag do begin
{ Get the Hershey Glyph number and the number of strokes in the font }
numString[0]:= #5;
eofFlag:= not GetNextRec(numString[1],5);
val(numString, GlyphNum, errPos);
numString[0]:= #3;
eofFlag:= not GetNextRec(numString[1],3);
val(numString, numStrokes, errPos);
if eofFlag then goto ExitLoad;
{ Allocate the memory for the character and store it}
if HersheyFontArray^[GlyphNum] = nil then begin
new(HersheyFontArray^[GlyphNum]);
HersheyFontArray^[GlyphNum]^.numStrokes:= numStrokes;
GetMem(HersheyFontArray^[GlyphNum]^.pStroke, numStrokes * 2);
{ Copy all the characters... }
eofFlag:= not GetNextRec(HersheyFontArray^[GlyphNum]^.pStroke^[1], 2*numStrokes);
if not eofFlag then eofFlag:= not GetNextRec(crlf[1], 2); { Get CR, LF }
if ((crlf[1] <> #13) or (crlf[2] <> #10)) then begin
writeln('Warning at character ', GlyphNum, '. Expected cr/lf not found! ');
writeln('Searching for next cr/lf...');
repeat
eofFlag:= not GetNextRec(crlf[1],1);
if not eofFlag and (crlf[1]=#13) then eofFlag:= not GetNextRec(crlf[2],1);
until ((crlf[1] = #13) and (crlf[2] = #10)) or eofFlag;
end;
end;
end;
ExitLoad:
CloseBlockFiles;
end;
{*****************************************************************************}
{* Throw away the font from memory. *}
{*****************************************************************************}
procedure HersheyDisposeFont;
var
i: integer;
begin
for i:= 1 to MaxHersheyChars do begin
if HersheyFontArray^[i] <> nil then begin
freemem(HersheyFontArray^[i]^.pStroke,HersheyFontArray^[i]^.numStrokes * 2);
dispose(HersheyFontArray^[i]);
HersheyFontArray^[i]:= nil;
end;
end;
Dispose(HersheyFontArray);
HersheyFontArray:= nil;
end;
{****************************************************************************}
{* HersheyDraw draws a line from the current Hershey line position to the *}
{* position x,y. *}
{* *}
{* The only system dependent routine. This routine calls the line routine *}
{* from the BGI toolkit. It can easily be exchanged to another routine on *}
{* any desired device. *}
{****************************************************************************}
procedure HersheyDraw(x,y : integer);
begin
Line(HersheyX,HersheyY,x,y); { BGI dependance }
HersheyX:= X; HersheyY:= Y;
end;
{****************************************************************************}
{* Sets the new Hershey current position to x,y *}
{****************************************************************************}
procedure HersheyMove(x,y : integer);
begin
HersheyX:= x; HersheyY:= y;
end;
{****************************************************************************}
{* Displays Glyph GlyphNum at the current position in the current size *}
{* and rotation. It updates the Hershey current position to fit for the *}
{* next character. *}
{****************************************************************************}
procedure HersheyDisplayGlyph(GlyphNum : integer);
var
skip : boolean;
i : integer;
xint, yint : integer;
xi, nu : integer; { Internal vectors of character }
dxi, dnu : integer; { Height and width information of character }
charX, charY : integer; { Position of the current character }
begin
{ Check if the character is valid }
if (GlyphNum < 1) or (GlyphNum > maxHersheyChars) then exit;
if HersheyFontArray^[GlyphNum]= nil then exit;
charX:= HersheyX; charY:= HersheyY; { Get current character position }
HersheyMove(charX, charY);
skip:= true;
with HersheyFontArray^[GlyphNum]^ do begin
{ Save the width information of the character }
dxi:= ord(pStroke^[1]) - ord('R');
dnu:= ord(pStroke^[2]) - ord('R');
{ Move to the center of the character }
charX:= charX - round(dxi*xiScale*cosTheta) { + round(GlyphHeightJustType * FontHeight * yScale * sinTheta)) };
charY:= charY + round(dxi*xiScale*sinTheta) { + round(GlyphHeightJustType * FontHeight * yScale * cosTheta)) };
for i:= 2 to numStrokes do begin
if pStroke^[i*2-1] = ' ' then skip:= true
else begin
xint:= ord(pStroke^[i*2-1]) - ord('R');
yint:= ord(pStroke^[i*2 ]) - ord('R');
if skip then begin
skip:= false;
HersheyMove(charX + round(xint * xiScale * cosTheta + yint * nuScale * sinTheta),
charY + round(-xint * xiScale * sinTheta + yint * nuScale * cosTheta));
end
else
HersheyDraw(charX + round(xint * xiScale * cosTheta + yint * nuScale * sinTheta),
charY + round(-xint * xiScale * sinTheta + yint * nuScale * cosTheta));
end;
end;
{ Move to the right side of the character }
charX:= charX - round(dxi*xiScale*cosTheta);
charY:= charY + round(dxi*xiScale*sinTheta);
HersheyMove(charX, charY);
end;
end;
{****************************************************************************}
{* Change the current Hershey font. *}
{****************************************************************************}
procedure HersheySetFont(var pFont);
begin
HersheyCurrentFont:= @pFont;
end;
{****************************************************************************}
{* Set the font rotation angle. *}
{****************************************************************************}
procedure HersheySetAngle(theta : double);
begin
SinTheta:= sin(theta/180*pi);
CosTheta:= cos(theta/180*pi);
end;
{***************************************************************************}
{* Sets the width and the height of the characters. *}
{* The size is given in Percent of the external Hershey character box *}
{* with respect to the maximal xposition. *}
{* *}
{* Note that most characters don't fill their character boxes and thus *}
{* will be much smaller than what might be believed. *}
{* *}
{* Also note that both the hight and width (xi and nu in the character *}
{* coordinates) are given in terms of percent of the maximal x value. *}
{* The aspect ratio can be modified by the value of HersheyAspectRatio. *}
{***************************************************************************}
procedure HersheySetGlyphSize(xs, ys: double);
begin
xiScale:= xs/100*HersheyMaxX/100;
nuScale:= ys/100*HersheyMaxX * HersheyAspectRatio/100;
end;
{***************************************************************************}
{* Sets the maximum x value and the aspect ration which are used in the *}
{* calculation of the Glyph size. *}
{***************************************************************************}
procedure HersheySetMaxX(maxX, aspectRatio: double);
begin
HersheyMaxX:= maxX;
HersheyAspectRatio:= aspectRatio;
end;
{***************************************************************************}
{* Returns the width of a Glyph. *}
{***************************************************************************}
function HersheyGlyphWidth(GlyphNum : integer) : double;
begin
if HersheyFontArray^[GlyphNum]=nil then begin
HersheyGlyphWidth:= 0;
exit;
end;
HersheyGlyphWidth:= xiScale * -2 * (ord(HersheyFontArray^[GlyphNum]^.pStroke^[1]) - ord('R'));
end;
{***************************************************************************}
{* Returns the height of a glyph. *}
{***************************************************************************}
function HersheyGlyphHeight(GlyphNum : integer) : double;
begin
if HersheyFontArray^[GlyphNum]=nil then begin
HersheyGlyphHeight:= 0;
exit;
end;
HersheyGlyphHeight:= nuScale * 2 * (ord(HersheyFontArray^[GlyphNum]^.pStroke^[2]) - ord('R'));
end;
{***************************************************************************}
{* Returns the width of a string in the current font... *}
{***************************************************************************}
function HersheyStringWidth(s : string) : double;
var
sum : double;
i : integer;
begin
sum:= 0;
for i:= 1 to length(s) do sum:= sum + HersheyGlyphWidth(HersheyCurrentFont^[s[i]]);
HersheyStringWidth:= sum;
end;
{**************************************************************************}
{* How to justify a string. *}
{* *}
{* -1 : left, bot justification *}
{* 0 : middle, centre justification *}
{* 1 : left top justification *}
{**************************************************************************}
procedure HersheySetStringJustify(horizontal, vertical : integer);
begin
HStringJust:= Horizontal;
VStringJust:= Vertical;
end;
{****************************************************************************}
{* Write the string s at the current Hershey pen position in the current *}
{* string justification. *}
{****************************************************************************}
procedure HersheyOutText(s : string);
var
i : integer;
stringWidth, stringHeight : integer;
dx, dy : integer;
x, y : integer;
d: double;
begin
x:= HersheyX; y:= HersheyY;
if HStringJust<> -1 then begin
d:= HersheyStringWidth(s);
stringWidth:= round(HersheyStringWidth(s));
dx:= round(stringWidth * cosTheta);
dy:= round(stringWidth * sinTheta);
if HStringJust=0 then begin
x:= x - dx div 2;
y:= y - dy div 2;
end
else begin
x:= x - dx;
y:= y - dy;
end;
end;
if VStringJust <> 0 then begin
stringHeight:= round(HersheyGlyphHeight(HersheyCurrentFont^['A']));
dx:= round(StringHeight * sinTheta);
dy:= round(StringHeight * cosTheta);
if VStringJust= 1 then begin
dx:= - dx div 2;
dy:= dy div 2;
end
else begin
dx:= dx div 2;
dy:= - dy div 2;
end;
x:= x+dx;
y:= y+dy;
end
else begin
dx:= 0;
dy:= 0;
end;
HersheyMove(x,y);
for i:= 1 to length(s) do
HersheyDisplayGlyph(HersheyCurrentFont^[s[i]]);
{ Move the pen pointer back to compensate for vertical justification }
if dx+dy <> 0 then HersheyMove(HersheyX-dx,HersheyY-dy);
end;
{****************************************************************************}
{* Like HersheyOutText, but writes the string at the position (x,y). *}
{****************************************************************************}
procedure HersheyOutTextXY(x,y : integer; s : string);
var
i : integer;
begin
HersheyMove(x,y);
HersheyOutText(s);
end;
{****************************************************************************}
{* Unit body. Initialize the parameters. *}
{****************************************************************************}
begin
HersheyMove(0,0);
HersheyFontArray:= nil;
HersheySetFont(HersheyRomanS);
HersheySetGlyphSize(5,5);
HersheySetAngle(0);
HersheySetStringJustify(-1,0);
HersheySetMaxX(640,1);
end.